home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / xlib.lha / xlib / cdecl / cdecl.scm < prev    next >
Text File  |  1990-05-31  |  6KB  |  167 lines
  1. ;;; C declaration compiler.
  2.  
  3. ;*              Copyright 1989 Digital Equipment Corporation
  4. ;*                         All Rights Reserved
  5. ;*
  6. ;* Permission to use, copy, and modify this software and its documentation is
  7. ;* hereby granted only under the following terms and conditions.  Both the
  8. ;* above copyright notice and this permission notice must appear in all copies
  9. ;* of the software, derivative works or modified versions, and any portions
  10. ;* thereof, and both notices must appear in supporting documentation.
  11. ;*
  12. ;* Users of this software agree to the terms and conditions set forth herein,
  13. ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
  14. ;* right and license under any changes, enhancements or extensions made to the
  15. ;* core functions of the software, including but not limited to those affording
  16. ;* compatibility with other hardware or software environments, but excluding
  17. ;* applications which incorporate this software.  Users further agree to use
  18. ;* their best efforts to return to Digital any such changes, enhancements or
  19. ;* extensions that they make and inform Digital of noteworthy uses of this
  20. ;* software.  Correspondence should be provided to Digital at:
  21. ;* 
  22. ;*                       Director of Licensing
  23. ;*                       Western Research Laboratory
  24. ;*                       Digital Equipment Corporation
  25. ;*                       100 Hamilton Avenue
  26. ;*                       Palo Alto, California  94301  
  27. ;* 
  28. ;* This software may be distributed (but not offered for sale or transferred
  29. ;* for compensation) to third parties, provided such third parties agree to
  30. ;* abide by the terms and conditions of this notice.  
  31. ;* 
  32. ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
  33. ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
  34. ;* MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
  35. ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
  36. ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
  37. ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
  38. ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
  39. ;* SOFTWARE.
  40.  
  41. ;;; This module is the main driver.  Expressions in the files names in the
  42. ;;; command line will be compiled and the stub module will be written to
  43. ;;; the standard output port.
  44.  
  45. (module cdecl
  46.     (main main)
  47.     (with const
  48.       extern
  49.       typedef
  50.       screp))
  51.  
  52. ;;; The following global variables hold lists of C declared items.
  53.  
  54. (define CDECL-CONSTANTS '())    ;;; List of constants
  55. (define CDECL-TYPES '())    ;;; List of types
  56. (define CDECL-READ-ONLY '())    ;;; List of read-only objects
  57. (define CDECL-DEFINE-ONLY '())    ;;; List of internal definitions
  58. (define CDECL-EXTERNS '())    ;;; List of external functions
  59.  
  60. ;;; Main program:
  61. ;;;
  62. ;;;     cdecl  class  command  cdecl-files...
  63. ;;;
  64. ;;; where "class" is the name of this set of declarations and "command" is
  65. ;;; one of the following:
  66. ;;;
  67. ;;;     -const            Emits constant definitions to the files
  68. ;;;                classCONSTANTS.sc and classCONSTANTS.sch.
  69. ;;;
  70. ;;;    -extern            Emits external procedures for each cdecl-file
  71. ;;;                containing extern definitions to files named
  72. ;;;                <cdecl-file-root>.sc and <cdecl-file-root>.sch.
  73. ;;;
  74. ;;;    -stubs            Emits stubs of form <C-procedure>* for all
  75. ;;;                C procedures to the file classSTUBS.sc.  This
  76. ;;;                allows the files produceded by -typedef to be
  77. ;;;                interpreted.
  78. ;;;
  79. ;;;    -typedef        Emits type definitions for structures to the
  80. ;;;                files <type-name>.sc and <type-name>.sch.
  81. ;;;                Emits all type checking functions and type
  82. ;;;                definitions for objects other than structs or
  83. ;;;                unions to classTYPES.sc and classTYPES.sch.
  84. ;;;
  85. ;;; The command is then followed by one or more files containing declarations.
  86. ;;; The declaration files normally have the file extension ".cdecl".
  87.  
  88. (define (MAIN clargs)
  89.   (initialize-types)
  90.   (set! CDECL-CONSTANTS '())    ;;; List of constants
  91.   (set! CDECL-TYPES '())    ;;; List of types
  92.   (set! CDECL-READ-ONLY '())    ;;; List of read-only objects
  93.   (set! CDECL-DEFINE-ONLY '())    ;;; List of internal definitions
  94.   (set! CDECL-EXTERNS '())    ;;; List of external functions
  95.     (let* ((class (if (>= (length clargs) 4)
  96.               (cadr clargs)
  97.               (error 'MAIN
  98.               "cdecl class {-const|-extern|-typedef} cdecl-files...")))
  99.        (const-file-root (string-append class "constants"))
  100.        (type-file-root (string-append class "types"))
  101.        (command (if (member (caddr clargs)
  102.                 '("-const" "-extern" "-typedef"))
  103.             (caddr clargs)
  104.                     (error 'MAIN "Unrecognized command: ~s"
  105.                    (cddr clargs)))))
  106.     (let loop ((files (cdddr clargs)))
  107.      (when files
  108.            (load-cdecl (car files))
  109.            (if (and (equal? command "-extern") cdecl-externs)
  110.            (emit-externs (reverse cdecl-externs)
  111.                (file-root (car files)) type-file-root))
  112.            (loop (cdr files))))
  113.     (if (equal? command "-const")
  114.     (emit-consts (reverse cdecl-constants) cdecl-define-only
  115.         const-file-root))
  116.     (if (equal? command "-typedef")
  117.     (emit-typedefs (reverse cdecl-types) cdecl-define-only
  118.         cdecl-read-only type-file-root))))
  119.  
  120. ;;; Returns a string that is the root of the file name.
  121.  
  122. (define (FILE-ROOT file)
  123.     (let loop ((fl (string->list file)))
  124.      (let ((x (member #\/ fl)))
  125.           (if x
  126.           (loop (cdr x))
  127.           (list->string
  128.               (let loop ((x fl))
  129.                (if (or (null? x) (equal? (car x) #\.))
  130.                    '()
  131.                    (cons (car x) (loop (cdr x))))))))))
  132.  
  133. ;;; A declaration is loaded into the system by the following function.
  134.  
  135. (define (LOAD-CDECL file)
  136.     (set! cdecl-externs '())
  137.     (with-input-from-file
  138.     file
  139.     (lambda ()
  140.         (let loop ((exp (read)))
  141.              (unless (eof-object? exp)
  142.                  (case (and (pair? exp) (car exp))
  143.                    ((const)
  144.                     (set! cdecl-constants
  145.                       (cons (input-const exp)
  146.                         cdecl-constants)))
  147.                    ((typedef)
  148.                     (set! cdecl-types
  149.                       (cons (input-typedef exp)
  150.                         cdecl-types)))
  151.                    ((extern)
  152.                     (set! cdecl-externs
  153.                       (cons (input-extern exp)
  154.                         cdecl-externs)))
  155.                    ((read-only)
  156.                     (set! cdecl-read-only
  157.                       (append (cdr exp)
  158.                           cdecl-read-only)))
  159.                    ((define-only)
  160.                     (set! cdecl-define-only
  161.                       (append (cdr exp)
  162.                           cdecl-define-only)))
  163.                    (else (error 'input-expressions
  164.                         "Unrecognized expression ~s"
  165.                         exp)))
  166.                  (loop (read)))))))
  167.